home *** CD-ROM | disk | FTP | other *** search
/ An Invitation to the Roland World of Music / Roland - An Invitation To The Roland World Of Music.bin / vb / mmsystem / vb_libs / midi_out.bas < prev    next >
BASIC Source File  |  1995-04-23  |  10KB  |  222 lines
  1. Option Explicit
  2. Dim m_hmidiout As Integer
  3.  
  4. ' **************************************************************************
  5. '
  6. '         Multimedia API Declares adapted from MMSYSTEM.H
  7. '
  8. '         Copyright (c) 1990-1993, Microsoft Corp.  All rights reserved.
  9. '
  10. ' **************************************************************************
  11.  
  12. Global Const MIDIERR_BASE = 64
  13.  
  14. ' ***************************************************************************
  15.  
  16. '                     General constants and data types
  17.  
  18. ' ****************************************************************************/
  19.  
  20. '  general constants
  21. Global Const MAXPNAMELEN = 32           '  max product name length (including NULL)
  22. Global Const MAXERRORLENGTH = 128       '  max error text length (including NULL)
  23.  
  24.  
  25. Global Const MM_MIM_OPEN = &H3C1                    '  MIDI input
  26. Global Const MM_MIM_CLOSE = &H3C2
  27. Global Const MM_MIM_DATA = &H3C3
  28. Global Const MM_MIM_LONGDATA = &H3C4
  29. Global Const MM_MIM_ERROR = &H3C5
  30. Global Const MM_MIM_LONGERROR = &H3C6
  31.  
  32. Global Const MM_MOM_OPEN = &H3C7                    '  MIDI output
  33. Global Const MM_MOM_CLOSE = &H3C8
  34. Global Const MM_MOM_DONE = &H3C9
  35.  
  36. ' ***************************************************************************
  37.  
  38. '                             MIDI audio support
  39.  
  40. ' ****************************************************************************/
  41.  
  42. '  MIDI error return values
  43. Global Const MIDIERR_UNPREPARED = (MIDIERR_BASE + 0)       '  header not prepared
  44. Global Const MIDIERR_STILLPLAYING = (MIDIERR_BASE + 1)     '  still something playing
  45. Global Const MIDIERR_NOMAP = (MIDIERR_BASE + 2)            '  no current map
  46. Global Const MIDIERR_NOTREADY = (MIDIERR_BASE + 3)         '  hardware is still busy
  47. Global Const MIDIERR_NODEVICE = (MIDIERR_BASE + 4)         '  port no longer connected
  48. Global Const MIDIERR_INVALIDSETUP = (MIDIERR_BASE + 5)     '  invalid setup
  49. Global Const MIDIERR_LASTERROR = (MIDIERR_BASE + 5)        '  last error in range
  50.  
  51. Global Const MIDIPATCHSIZE = 128
  52.  
  53. '  MIDI callback messages
  54. Global Const MIM_OPEN = MM_MIM_OPEN
  55. Global Const MIM_CLOSE = MM_MIM_CLOSE
  56. Global Const MIM_DATA = MM_MIM_DATA
  57. Global Const MIM_LONGDATA = MM_MIM_LONGDATA
  58. Global Const MIM_ERROR = MM_MIM_ERROR
  59. Global Const MIM_LONGERROR = MM_MIM_LONGERROR
  60. Global Const MOM_OPEN = MM_MOM_OPEN
  61. Global Const MOM_CLOSE = MM_MOM_CLOSE
  62. Global Const MOM_DONE = MM_MOM_DONE
  63.  
  64. '  device ID for MIDI mapper
  65. Global Const MIDIMAPPER = (-1)
  66. Global Const MIDI_MAPPER = (-1)
  67.  
  68. '  flags for wFlags parm of midiOutCachePatches(), midiOutCacheDrumPatches()
  69. Global Const MIDI_CACHE_ALL = 1
  70. Global Const MIDI_CACHE_BESTFIT = 2
  71. Global Const MIDI_CACHE_QUERY = 3
  72. Global Const MIDI_UNCACHE = 4
  73.  
  74. '  MIDI output device capabilities structure
  75. Type MIDIOUTCAPS
  76.     wMid As Integer                  '  manufacturer ID
  77.     wPid As Integer                  '  product ID
  78.     vDriverVersion As Integer        '  version of the driver
  79.     szPname As String * MAXPNAMELEN  '  product name (NULL terminated string)
  80.     wTechnology As Integer           '  type of device
  81.     wVoices As Integer               '  # of voices (internal synth only)
  82.     wNotes As Integer                '  max # of notes (internal synth only)
  83.     wChannelMask As Integer          '  channels used (internal synth only)
  84.     dwSupport As Long             '  functionality supported by driver
  85. End Type
  86.  
  87. '  flags for wTechnology field of MIDIOUTCAPS structure
  88. Global Const MOD_MIDIPORT = 1      '  output port
  89. Global Const MOD_SYNTH = 2         '  generic internal synth
  90. Global Const MOD_SQSYNTH = 3       '  square wave internal synth
  91. Global Const MOD_FMSYNTH = 4       '  FM internal synth
  92. Global Const MOD_MAPPER = 5        '  MIDI mapper
  93.  
  94. '  flags for dwSupport field of MIDIOUTCAPS structure
  95. Global Const MIDICAPS_VOLUME = &H1               '  supports volume control
  96. Global Const MIDICAPS_LRVOLUME = &H2             '  separate left-right volume control
  97. Global Const MIDICAPS_CACHE = &H4
  98.  
  99. '  MIDI output device capabilities structure
  100. Type MIDIINCAPS
  101.     wMid As Integer                  '  manufacturer ID
  102.     wPid As Integer                  '  product ID
  103.     vDriverVersion As Integer        '  version of the driver
  104.     szPname As String * MAXPNAMELEN  '  product name (NULL terminated string)
  105. End Type
  106.  
  107. '  MIDI data block header
  108. Type MIDIHDR
  109.     lpData As Long               '  pointer to locked data block
  110.     dwBufferLength As Long       '  length of data in data block
  111.     dwBytesRecorded As Long      '  used for input only
  112.     dwUser As Long               '  for client's use
  113.     dwFlags As Long              '  assorted flags (see defines)
  114.     midihdr_tag As Long          '  reserved for driver
  115.     reserved As Long             '  reserved for driver
  116. End Type
  117.  
  118. '  flags for dwFlags field of MIDIHDR structure
  119. Global Const MHDR_DONE = &H1                     '  done bit
  120. Global Const MHDR_PREPARED = &H2                 '  set if header prepared
  121. Global Const MHDR_INQUEUE = &H4                  '  reserved for driver
  122.  
  123. '  MIDI function prototypes
  124. Declare Function midiOutGetNumDevs Lib "MMSYSTEM" () As Integer
  125. Declare Function midiOutGetDevCaps Lib "MMSYSTEM" (ByVal udeviceid As Integer, lpCaps As MIDIOUTCAPS, ByVal uSize As Integer) As Integer
  126. Declare Function midiOutGetVolume Lib "MMSYSTEM" (ByVal udeviceid As Integer, lpdwvolume As Long) As Integer
  127. Declare Function midiOutSetVolume Lib "MMSYSTEM" (ByVal udeviceid As Integer, ByVal dwVolume As Long) As Integer
  128. Declare Function midiOutGetErrorText Lib "MMSYSTEM" (ByVal uError As Integer, ByVal lpText As String, ByVal uSize As Integer) As Integer
  129. Declare Function midiOutOpen Lib "MMSYSTEM" (lphMidiOut As Integer, ByVal udeviceid As Integer, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Integer
  130. Declare Function midiOutClose Lib "MMSYSTEM" (ByVal hmidiout As Integer) As Integer
  131. Declare Function midiOutPrepareHeader Lib "MMSYSTEM" (ByVal hmidiout As Integer, lphMidiOut As MIDIHDR, ByVal uSize As Integer) As Integer
  132. Declare Function midiOutUnprepareHeader Lib "MMSYSTEM" (ByVal hmidiout As Integer, lphMidiOut As MIDIHDR, ByVal uSize As Integer) As Integer
  133. Declare Function midiOutShortMsg Lib "MMSYSTEM" (ByVal hmidiout As Integer, ByVal dwMsg As Long) As Integer
  134. Declare Function midiOutLongMsg Lib "MMSYSTEM" (ByVal hmidiout As Integer, lphMidiOut As MIDIHDR, ByVal uSize As Integer) As Integer
  135. Declare Function midiOutReset Lib "MMSYSTEM" (ByVal hmidiout As Integer) As Integer
  136. Declare Function midiOutCachePatches Lib "MMSYSTEM" (ByVal hmidiout As Integer, ByVal uBank As Integer, ByVal PatchArray As Long, ByVal uFlags As Integer) As Integer
  137. Declare Function midiOutCacheDrumPatches Lib "MMSYSTEM" (ByVal hmidiout As Integer, ByVal uPatch As Integer, lpwKeyArray As Integer, ByVal uFlags As Integer) As Integer
  138. Declare Function midiOutGetID Lib "MMSYSTEM" (ByVal hmidiout As Integer, lpudeviceid As Integer) As Integer
  139. Declare Function midiOutMessage Lib "MMSYSTEM" (ByVal hmidiout As Integer, ByVal uMessage As Integer, ByVal dw1 As Long, ByVal dw2 As Long) As Long
  140. Declare Function midiInGetNumDevs Lib "MMSYSTEM" () As Integer
  141. Declare Function midiInGetDevCaps Lib "MMSYSTEM" (ByVal udeviceid As Integer, lpCaps As MIDIINCAPS, ByVal uSize As Integer) As Integer
  142. Declare Function midiInGetErrorText Lib "MMSYSTEM" (ByVal uError As Integer, ByVal lpText As String, ByVal uSize As Integer) As Integer
  143. Declare Function midiInOpen Lib "MMSYSTEM" (lphMidiIn As Integer, ByVal udeviceid As Integer, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Integer
  144. Declare Function midiInClose Lib "MMSYSTEM" (ByVal hMidiIn As Integer) As Integer
  145. Declare Function midiInPrepareHeader Lib "MMSYSTEM" (ByVal hMidiIn As Integer, lpMidiInHdr As MIDIHDR, ByVal uSize As Integer) As Integer
  146. Declare Function midiInUnprepareHeader Lib "MMSYSTEM" (ByVal hMidiIn As Integer, lpMidiInHdr As MIDIHDR, ByVal uSize As Integer) As Integer
  147. Declare Function midiInAddBuffer Lib "MMSYSTEM" (ByVal hMidiIn As Integer, lpMidiInHdr As MIDIHDR, ByVal uSize As Integer) As Integer
  148. Declare Function midiInStart Lib "MMSYSTEM" (ByVal hMidiIn As Integer) As Integer
  149. Declare Function midiInStop Lib "MMSYSTEM" (ByVal hMidiIn As Integer) As Integer
  150. Declare Function midiInReset Lib "MMSYSTEM" (ByVal hMidiIn As Integer) As Integer
  151. Declare Function midiInGetID Lib "MMSYSTEM" (ByVal hMidiIn As Integer, lpudeviceid As Integer) As Integer
  152. Declare Function midiInMessage Lib "MMSYSTEM" (ByVal hMidiIn As Integer, ByVal uMessage As Integer, ByVal dw1 As Long, ByVal dw2 As Long) As Long
  153.  
  154.  
  155. Sub midi_listoutdevs (c As Control)
  156. Dim i As Integer
  157. Dim x As Integer
  158. Dim midicaps As MIDIOUTCAPS
  159.  
  160.     c.Clear
  161.     ' Test for MIDI mapper
  162.     If midiOutGetDevCaps(MIDIMAPPER, midicaps, Len(midicaps)) = 0 Then ' OK
  163.     c.AddItem midicaps.szPname
  164.     c.ItemData(c.NewIndex) = MIDIMAPPER ' Save dev_id in item data
  165.     End If
  166.     ' Add other devs
  167.     For i = 0 To midiOutGetNumDevs() - 1
  168.     If midiOutGetDevCaps(i, midicaps, Len(midicaps)) = 0 Then ' OK
  169.         c.AddItem midicaps.szPname
  170.         c.ItemData(c.NewIndex) = i ' Save dev_id
  171.     End If
  172.     Next
  173. End Sub
  174.  
  175. Sub midi_out_close ()
  176. Dim midi_error As Integer
  177.  
  178.     If m_hmidiout <> 0 Then
  179.     midi_error = midiOutClose(m_hmidiout)
  180.     If Not midi_error = 0 Then
  181.         Call midi_outerr(midi_error)
  182.     End If
  183.     m_hmidiout = 0
  184.     End If
  185. End Sub
  186.  
  187. Function midi_out_open (ByVal dev_id As Integer) As Integer
  188. Dim midi_error As Integer
  189.  
  190.     midi_out_close ' just in case (And it dont hurt)
  191.     midi_error = midiOutOpen(m_hmidiout, dev_id, 0, 0, 0)
  192.     If Not midi_error = 0 Then
  193.     Call midi_outerr(midi_error)
  194.     End If
  195.     midi_out_open = (m_hmidiout <> 0)
  196. End Function
  197.  
  198. Sub midi_outerr (ByVal midi_error As Integer)
  199. Dim s As String
  200. Dim x As Integer
  201.  
  202.     s = Space(MAXERRORLENGTH)
  203.     x = midiOutGetErrorText(midi_error, s, MAXERRORLENGTH)
  204.     'If Not g_debug Then
  205.     MsgBox s
  206.     'End If
  207. End Sub
  208.  
  209. Sub midi_outshort (b1 As Integer, b2 As Integer, b3 As Integer)
  210. Dim midi_error As Integer
  211.  
  212.     midi_error = midiOutShortMsg(m_hmidiout, packdword(0, b3, b2, b1))
  213.     If Not midi_error = 0 Then
  214.     Call midi_outerr(midi_error)
  215.     End If
  216. End Sub
  217.  
  218. Function packdword (i1 As Integer, i2 As Integer, i3 As Integer, i4 As Integer) As Long
  219.     packdword = i2 * &H10000 + i3 * &H100 + i4
  220. End Function
  221.  
  222.